home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / INITKEY.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  4.0 KB  |  99 lines
  1. ;;;
  2. ;;;     Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;     This material was developed by the Scheme project at the
  5. ;;;     Massachusetts Institute of Technology, Department of
  6. ;;;     Electrical Engineering and Computer Science.  Permission to
  7. ;;;     copy this software, to redistribute it, and to use it for any
  8. ;;;     purpose is granted, subject to the following restrictions and
  9. ;;;     understandings.
  10. ;;;
  11. ;;;     1. Any copy made of this software must include this copyright
  12. ;;;     notice in full.
  13. ;;;
  14. ;;;     2. Users of this software agree to make their best efforts (a)
  15. ;;;     to return to the MIT Scheme project any improvements or
  16. ;;;     extensions that they make, so that these may be included in
  17. ;;;     future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;     this software.
  19. ;;;
  20. ;;;     3.  All materials developed as a consequence of the use of
  21. ;;;     this software shall duly acknowledge such use, in accordance
  22. ;;;     with the usual standards of acknowledging credit in academic
  23. ;;;     research.
  24. ;;;
  25. ;;;     4. MIT has made no warrantee or representation that the
  26. ;;;     operation of this software will be error-free, and MIT is
  27. ;;;     under no obligation to provide any services, by way of
  28. ;;;     maintenance, update, or otherwise.
  29. ;;;
  30. ;;;     5.  In conjunction with products arising from the use of this
  31. ;;;     material, there shall be no use of the name of the
  32. ;;;     Massachusetts Institute of Technology nor of any adaptation
  33. ;;;     thereof in any advertising, promotional, or sales literature
  34. ;;;     without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43. (define define-initial-key
  44.   (letrec
  45.     ((%prefix
  46.        (lambda (alists char)
  47.          (let ((upcase (char-upcase char)))
  48.            (%set-comtab-entry! alists upcase %command)
  49.            (if (char-alphabetic? char)
  50.                (%set-comtab-entry! alists (char-downcase char) %command)))))
  51.      (%command '()))
  52.  
  53.     (lambda (char command)
  54.       (cond ((char? char)
  55.              (%set-comtab-key comtab (char-upcase char) command)
  56.              (if (char-alphabetic?  char)
  57.                  (%set-comtab-key comtab (char-downcase char) command)))
  58.             ((and (pair? char) (null? (cdr char)))
  59.              (%set-comtab-key comtab (char-upcase (car char)) command)
  60.              (if (char-alphabetic?  (car char))
  61.                  (%set-comtab-key comtab (char-downcase (car char)) command)))
  62.             ((pair? char)
  63.              (set! %command command)
  64.              (comtab-lookup-prefix char %prefix))
  65.           ((char-set? char)
  66.            (mapc (lambda (char) (set-comtab-entry! char command))
  67.                  (char-set-members char)))
  68.           (else (error "Unknown character" char)))
  69.       char)))
  70.  
  71. (define define-initial-prefix-key
  72.   (letrec
  73.     ((%prefix
  74.         (lambda (alists char)
  75.           (let ((upcase (char-upcase char)))
  76.             (if (pair? %char)
  77.                 (%set-comtab-entry! alists upcase %command)
  78.                 (%set-comtab-key alists upcase %command))
  79.             (%comtab-make-prefix-char! alists upcase (cons '() '()))
  80.             (if (char-alphabetic? char)
  81.                 (%comtab-make-synonym-char! alists (char-downcase char)
  82.                                             alists upcase)))))
  83.      (%char '())
  84.      (%command '()))
  85.  
  86.   (lambda (char command)
  87.     (cond ((or (char? char) (pair? char))
  88.            (set! %command command)
  89.            (set! %char char)
  90.            (comtab-lookup-prefix char %prefix))
  91.           (else (error "Unknown character" char)))
  92.     char)))
  93.  
  94. (define (define-initial-default-key command)
  95.   (set! default-key command)
  96.   (set-cdr! comtab (make-vector 256 command)))
  97.                                 ;;; change to 256 for internationalize
  98.  
  99.